home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-01 / cexpert.zip / MCH5.LST < prev    next >
File List  |  1990-09-15  |  10KB  |  338 lines
  1.           Listing 5-1 Unification for Prolog
  2. /************************************************************************
  3.  
  4.     Unification Implementation
  5.  
  6. Convention:  Substitutions returned by unify-xxx are for the FIRST argument.
  7.  
  8. It makes no sense to mix substitutions of two expressions!! the variable names
  9. are relative to each expression, so that it makes no sense to mix them.
  10. Ex:  (unify-pred '(p ?x 1) '(p 2 ?x))  should work fine, but what to return?
  11.  
  12. PRED is LIST w/first term nonvar symbol assumed
  13. PROP is EXP w/first term nonvar symbol assumed, rest terms are PROPS.
  14.  
  15. Could make all unify-xxx fns faster by making loop, instead of recursion.
  16. ***********************************************************************/
  17.  
  18. /*-----------------------------------------------------include------------*/
  19.  
  20. #include <stdio.h>
  21. #include "cons.h"
  22. #include "goal.h"
  23.  
  24.  
  25. /*------------------------------------------------------unify_equal()------*/
  26.  
  27. /*
  28. ** unify_equal: Does not handle varterms
  29. ** This is the KEY, inner loop operation performed for unification
  30. ** in the reasoning system.  As such, we would like to make it as efficient
  31. ** as possible.  Two terms are considered equal for the purposes of 
  32. ** unification if one of two conditions are met:
  33. ** * They are #'equal (a la lisp)
  34. **
  35. ** * They denote an equivalent number
  36. **
  37. **  Example:unify-equal ('3, '3) --> ((t t))
  38. **          unify-equal ('p, ?X) --> NIL
  39. */ 
  40.  
  41. cons *unify_equal(term1,term2)
  42. cons *term1,*term2;
  43. {
  44.   return (!strcmp(term1->car.s,term2->car.s)) ? mklist2("t","t") : NULL;
  45. }
  46.  
  47.  
  48.  
  49. /*---------------------------------------------------unify_term_c()------*/
  50.      
  51. /*
  52. ** unify_term_c:
  53. ** Term unification, with second arg unsubstitutable.
  54. ** Example: unify_term_c(?a, 3) --> ((?a . 3))
  55. **          unify_term_c(3, ?a) --> nil
  56. **
  57. ** Used for slot and variable values.
  58. */
  59.           
  60. cons *unify_term_c(accom_term,const_term) 
  61. cons *accom_term,*const_term;
  62. {
  63.   if (variablep(accom_term)) {
  64.     return mklist2(accom_term->car.s,const_term->car.s);
  65.   } else {
  66.     return unify_equal(accom_term,const_term);
  67.   }
  68. }
  69.  
  70.  
  71.  
  72.  
  73. /*---------------------------------------------------unify_term()------*/
  74.  
  75. /*
  76. ** unify_term: Handles var-terms
  77. ** Used for predicate EQUAL.
  78. **
  79. ** Example: unify_term(?a, 3) --> ((?a . 3))
  80. **           unify_term(3, ?a) --> ((?a . 3))
  81. **
  82. */
  83.  
  84. cons *unify_term(term1,term2)
  85. cons *term1,*term2;
  86. {
  87.   if (variablep(term1)) {
  88.     return mklist2(term1->car.s,term2->car.s);
  89.   } else if (variablep(term2)) {
  90.     return mklist2(term2->car.s,term1->car.s);
  91.   } else {
  92.     return unify_equal(term1,term2);
  93.   }
  94. }
  95.  
  96.  
  97.  
  98.  
  99. /*---------------------------------------------------unify_pred_c()------*/
  100.  
  101. /*
  102. ** unify_pred_c: Predicate Unification with second predicate constant.
  103. ** finds substitution s that makes accom-exp . s = const-exp
  104. **
  105. **  Example: unify-pred-C '(P ?X 5) '(P 3 ?y) ==> nil
  106. **           unify-Pred-C '(P ?X ?Y) '(P 2 ?Y) ==> '((?X . 2))
  107. **
  108. ** Typically first arg is goal and second is fact w/no vars.è*/
  109.  
  110. cons *unify_pred_c(accom_pred,const_pred)
  111. cons *accom_pred,*const_pred;
  112. {
  113. if(equal(accom_pred,const_pred))
  114.   return ltwotees();
  115.   if (length(const_pred) == length(accom_pred) &&
  116.       !strcmp(const_pred->car.p->car.s,accom_pred->car.p->car.s)) {
  117.     return unify_list_c_1(accom_pred->cdr,const_pred->cdr);
  118.   } else {
  119.     return NULL;
  120.   }
  121. }
  122.  
  123.  
  124.  
  125. /*---------------------------------------------------unify_list_c_1()------*/
  126.  
  127. /*
  128. ** unify_list_c_1() Aux fn that does not check length.
  129. ** This is an auxiliary for unify_pred_c.
  130. */
  131.  
  132. cons *unify_list_c_1 (ap,cp)
  133. cons *ap,*cp;
  134. {
  135.   cons *subst = NULL;
  136.   cons *apterm = ap->car.p;
  137.   cons *cpterm = cp->car.p;
  138.   cons *tmp;
  139.  
  140.   while (apterm != NULL) {
  141.     if (tmp = unify_equal(apterm,cpterm)) {
  142.        killcons(tmp);
  143.     } else if (variablep(apterm)) {
  144.       tmp = mkcons(CAR_LIST,mklist2(apterm->car.s,cpterm->car.s),NULL);
  145.       subst = nconc(subst,tmp);
  146.     } else {
  147.       return NULL;
  148.     }
  149.     ap = ap->cdr; cp = cp->cdr;
  150.     apterm = ap->car.p;
  151.     cpterm = cp->car.p;
  152.   }
  153.   if (subst == NULL) {
  154.     return mkcons(CAR_LIST,mklist2("t","t"),NULL);
  155.   } else {
  156.     return subst;
  157.   }
  158. }
  159.  
  160.  
  161.  
  162. /*---------------------------------------------------unify_pred_nv()------*/è
  163. /*
  164. ** unify_pred_nv(): Like U-P, but only returns substitution for terms
  165. ** that are nonvar in const_pred.  Used in backward-chain.
  166. **
  167. ** Example (unify_pred_nv ((p 1 ?x ?z),(p ?y 1 ?x))) --> (((?x 1))((?x z)))
  168. **
  169. ** the second value returned is for the terms that are var in both (for use
  170. ** in translating prev-substs.)
  171. */
  172.  
  173. cons *unify_pred_nv(accom_pred,const_pred) 
  174. cons *accom_pred,*const_pred;
  175. {
  176.   if(equal(accom_pred,const_pred))
  177.     return mkcons(CAR_LIST,ltwotees(),mkcons(CAR_LIST,ltwotees(),NULL));
  178.   if (length(const_pred) == length(accom_pred) &&
  179.       !strcmp(const_pred->car.p->car.s,accom_pred->car.p->car.s)) {
  180.     return unify_list_nv_1(accom_pred->cdr,const_pred->cdr);
  181.   } else {
  182.     return NULL;
  183.   }
  184. }
  185.  
  186.  
  187.  
  188. /*-----------------------------------------------unify_list_nv_1()------*/
  189.  
  190. /*
  191. ** unify_list_nv_1(): Aux fn that does not check length.
  192. */
  193.  
  194. cons *unify_list_nv_1(ap, cp)
  195. cons *ap,*cp;
  196. {
  197.   cons *subst = NULL,*subst2 = NULL;
  198.   cons *apterm = ap->car.p;
  199.   cons *cpterm = cp->car.p;
  200.   cons *tmp,*retval;
  201.     
  202.   while (apterm != NULL) {
  203.     if (tmp = unify_equal(apterm,cpterm)) {
  204.        killcons(tmp);
  205.     } else if (variablep(cpterm)) {
  206.       if (variablep(apterm)) {
  207.     subst2 = nconc(subst2,mkcons(CAR_LIST,
  208.                      mklist2(cpterm->car.s,apterm->car.s),
  209.                      NULL));
  210.       }
  211.     } else if (variablep(apterm)) {
  212.       subst = nconc(subst,mkcons(CAR_LIST,
  213.                      mklist2(apterm->car.s,cpterm->car.s),
  214.                  NULL));
  215.     } else {      return NULL;
  216.     }
  217.     ap = ap->cdr; cp = cp->cdr;
  218.     apterm = ap->car.p;
  219.     cpterm = cp->car.p;
  220.   }
  221.   return mkcons(CAR_LIST,
  222.           (subst == NULL) ? mkcons(CAR_LIST,mklist2("t","t"),NULL)
  223.                   : subst,
  224.           mkcons(CAR_LIST,(subst2 == NULL) ? mkcons(CAR_LIST,
  225.                                 mklist2("t","t"),
  226.                                 NULL) 
  227.                            : subst2));
  228.  
  229. }
  230.  
  231.  
  232.  
  233.                 Listing 5-2 Backtracking Program 
  234.  
  235.  
  236. /**********************************************************************
  237.             Implementation of Backtracking
  238.  
  239. The first call to a conjunction will leave this data structure around.
  240. #s(GOAL-STACK :GOAL (AND (Q ?Y) (P ?X)) :PREV-SUBSTS (((?Y . 1) (?X . 1)))
  241.           :GOAL-STACK (#s(GOAL-FRAME :GOAL (P ?X) :SIT ((?Y . 1)) :PS NIL
  242.                      :ROC NIL :SOLN ((?X . 1)) :CERT 1.0)
  243.                #s(GOAL-FRAME :GOAL (Q ?Y) :SIT NIL :PS NIL
  244.                      :ROC ((P ?X)) :SOLN ((?Y . 1))
  245.                      :CERT 0.8)))
  246.  
  247. We save a goal stack for every conjunction that is called initially.  When
  248. that conjunction is called again, we use the same goal stack.  Possible 
  249. problem: a conjunction called in two places might need two different goal 
  250. stacks!!
  251.  
  252. ********************************************************************** */
  253.  
  254. /*------------------------------------------------------include-----------*/
  255.  
  256. #include   <stdio.h>
  257. #include   <math.h>
  258. #include   "cons.h"
  259. #include   "goal.h"
  260.  
  261. /*------------------------------------------------------global variable---*/
  262.  
  263. Goal_Stack  *GOAL_STACK;                /*declare the global GOAL_STACK*/
  264.  
  265. /*------------------------------------------------------backtrack()--------*/
  266.  
  267. /*
  268. **    backtrak.c
  269. **    Description:   This program is to implement backtrack step in reasoning.
  270. */
  271.  
  272.  
  273. /* Gets another solution to the current goal.  As above, only returns 
  274. ** solution for strictly current goal.  Caller should add s_i_t.
  275. ** If Once? is t, then backtracking will only happen by one frame.
  276. */
  277.  
  278. Ret_Pair  *Backtrack(gs_obj,once)
  279.  
  280. Goal_Stack   *gs_obj;                         /*goal stack object*/
  281. int          once;                  /*tried or not flag*/
  282.  
  283. /*------------------------------------------------------------------------*/
  284. {
  285.     Ret_Pair       *ret_pair;        /*return pair: subst,cert*/
  286.         Ret_Pair       *temp_pair1,*temp_pair2;
  287.     Goal_Frame     *gf;
  288.     cons           *new_prev_substs,*tmp1;
  289.     double         *cert;
  290.  
  291.     #ifdef DEBUG
  292.         printf("\nIn Backtrack");
  293.         printf("\ngs_obj ::");
  294.         print_goal_obj(gs_obj);
  295.         printf("\nonce == %d",once);
  296.     #endif
  297.     
  298.     ret_pair   = init_ret_pair();    /*initialize the return pair*/
  299.     temp_pair1 = init_ret_pair();
  300.     
  301.     gf = pop_a_frame(gs_obj);      /*pop a goal frame from goal_stack*/
  302.     if(gf != NULL)              /*pop up success*/
  303.     {
  304.         new_prev_substs = mkcons(CAR_LIST,gf->soln,gf->ps);    
  305.         temp_pair1 = achieve(gf->goal,new_prev_substs);
  306.         if(temp_pair1->subst != NULL)
  307.         {
  308.             gf->ps = new_prev_substs;
  309.             gf->soln = temp_pair1->subst;
  310.             gf->cert = temp_pair1->certainty;
  311.             push_a_frame(gf,gs_obj);
  312.             tmp1 = gf->sit;
  313.             temp_pair2 = Frwdtrack(gs_obj,
  314.                             subst_prop(gf->roc,temp_pair1->subst),
  315.                             nconc(tmp1,temp_pair1->subst),FALSE);
  316.             if(temp_pair2->subst != NULL)
  317.             {
  318.                tmp1 = temp_pair1->subst;
  319.                ret_pair->subst = nconc(tmp1,temp_pair2->subst);
  320.                Min(temp_pair1->certainty,temp_pair2->certainty,cert);
  321.                ret_pair->certainty = (*cert);
  322.                return ret_pair;
  323.                 }
  324.             else
  325.             {
  326.                return Backtrack(gs_obj,once);
  327.                 }
  328.            }
  329.            else if(once == FALSE)
  330.                 {
  331.             return Backtrack(gs_obj,FALSE);
  332.             }
  333.      }
  334. }
  335.             
  336.  
  337.  
  338.